home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / calc202a.lha / calc-2.02a / calc-frac.el < prev    next >
Lisp/Scheme  |  1993-06-01  |  6KB  |  236 lines
  1. ;; Calculator for GNU Emacs, part II [calc-frac.el]
  2. ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  3. ;; Written by Dave Gillespie, daveg@synaptics.com.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22.  
  23.  
  24. ;; This file is autoloaded from calc-ext.el.
  25. (require 'calc-ext)
  26.  
  27. (require 'calc-macs)
  28.  
  29. (defun calc-Need-calc-frac () nil)
  30.  
  31.  
  32. (defun calc-fdiv (arg)
  33.   (interactive "P")
  34.   (calc-slow-wrapper
  35.    (calc-binary-op ":" 'calcFunc-fdiv arg 1))
  36. )
  37.  
  38.  
  39. (defun calc-fraction (arg)
  40.   (interactive "P")
  41.   (calc-slow-wrapper
  42.    (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac)))
  43.      (if (eq arg 0)
  44.      (calc-enter-result 2 "frac" (list func
  45.                        (calc-top-n 2)
  46.                        (calc-top-n 1)))
  47.        (calc-enter-result 1 "frac" (list func
  48.                      (calc-top-n 1)
  49.                      (prefix-numeric-value (or arg 0)))))))
  50. )
  51.  
  52.  
  53. (defun calc-over-notation (fmt)
  54.   (interactive "sFraction separator (:, ::, /, //, :/): ")
  55.   (calc-wrapper
  56.    (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt)
  57.        (let ((n nil))
  58.      (if (/= (match-end 0) (match-end 1))
  59.          (setq n (string-to-int (substring fmt (match-end 1)))
  60.            fmt (math-match-substring fmt 1)))
  61.      (if (eq n 0) (error "Bad denominator"))
  62.      (calc-change-mode 'calc-frac-format (list fmt n) t))
  63.      (error "Bad fraction separator format.")))
  64. )
  65.  
  66. (defun calc-slash-notation (n)
  67.   (interactive "P")
  68.   (calc-wrapper
  69.    (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))
  70. )
  71.  
  72.  
  73. (defun calc-frac-mode (n)
  74.   (interactive "P")
  75.   (calc-wrapper
  76.    (calc-change-mode 'calc-prefer-frac n nil t)
  77.    (message (if calc-prefer-frac
  78.         "Integer division will now generate fractions."
  79.           "Integer division will now generate floating-point results.")))
  80. )
  81.  
  82.  
  83.  
  84.  
  85.  
  86. ;;;; Fractions.
  87.  
  88. ;;; Build a normalized fraction.  [R I I]
  89. ;;; (This could probably be implemented more efficiently than using
  90. ;;;  the plain gcd algorithm.)
  91. (defun math-make-frac (num den)
  92.   (if (Math-integer-negp den)
  93.       (setq num (math-neg num)
  94.         den (math-neg den)))
  95.   (let ((gcd (math-gcd num den)))
  96.     (if (eq gcd 1)
  97.     (if (eq den 1)
  98.         num
  99.       (list 'frac num den))
  100.       (if (equal gcd den)
  101.       (math-quotient num gcd)
  102.     (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
  103. )
  104.  
  105. (defun calc-add-fractions (a b)
  106.   (if (eq (car-safe a) 'frac)
  107.       (if (eq (car-safe b) 'frac)
  108.       (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
  109.                     (math-mul (nth 2 a) (nth 1 b)))
  110.               (math-mul (nth 2 a) (nth 2 b)))
  111.     (math-make-frac (math-add (nth 1 a)
  112.                   (math-mul (nth 2 a) b))
  113.             (nth 2 a)))
  114.     (math-make-frac (math-add (math-mul a (nth 2 b))
  115.                   (nth 1 b))
  116.             (nth 2 b)))
  117. )
  118.  
  119. (defun calc-mul-fractions (a b)
  120.   (if (eq (car-safe a) 'frac)
  121.       (if (eq (car-safe b) 'frac)
  122.       (math-make-frac (math-mul (nth 1 a) (nth 1 b))
  123.               (math-mul (nth 2 a) (nth 2 b)))
  124.     (math-make-frac (math-mul (nth 1 a) b)
  125.             (nth 2 a)))
  126.     (math-make-frac (math-mul a (nth 1 b))
  127.             (nth 2 b)))
  128. )
  129.  
  130. (defun calc-div-fractions (a b)
  131.   (if (eq (car-safe a) 'frac)
  132.       (if (eq (car-safe b) 'frac)
  133.       (math-make-frac (math-mul (nth 1 a) (nth 2 b))
  134.               (math-mul (nth 2 a) (nth 1 b)))
  135.     (math-make-frac (nth 1 a)
  136.             (math-mul (nth 2 a) b)))
  137.     (math-make-frac (math-mul a (nth 2 b))
  138.             (nth 1 b)))
  139. )
  140.  
  141.  
  142.  
  143.  
  144. ;;; Convert a real value to fractional form.  [T R I; T R F] [Public]
  145. (defun calcFunc-frac (a &optional tol)
  146.   (or tol (setq tol 0))
  147.   (cond ((Math-ratp a)
  148.      a)
  149.     ((memq (car a) '(cplx polar vec hms date sdev intv mod))
  150.      (cons (car a) (mapcar (function
  151.                 (lambda (x)
  152.                   (calcFunc-frac x tol)))
  153.                    (cdr a))))
  154.     ((Math-messy-integerp a)
  155.      (math-trunc a))
  156.     ((Math-negp a)
  157.      (math-neg (calcFunc-frac (math-neg a) tol)))
  158.     ((not (eq (car a) 'float))
  159.      (if (math-infinitep a)
  160.          a
  161.        (if (math-provably-integerp a)
  162.            a
  163.          (math-reject-arg a 'numberp))))
  164.     ((integerp tol)
  165.      (if (<= tol 0)
  166.          (setq tol (+ tol calc-internal-prec)))
  167.      (calcFunc-frac a (list 'float 5
  168.                 (- (+ (math-numdigs (nth 1 a))
  169.                       (nth 2 a))
  170.                    (1+ tol)))))
  171.     ((not (eq (car tol) 'float))
  172.      (if (Math-realp tol)
  173.          (calcFunc-frac a (math-float tol))
  174.        (math-reject-arg tol 'realp)))
  175.     ((Math-negp tol)
  176.      (calcFunc-frac a (math-neg tol)))
  177.     ((Math-zerop tol)
  178.      (calcFunc-frac a 0))
  179.     ((not (math-lessp-float tol '(float 1 0)))
  180.      (math-trunc a))
  181.     ((Math-zerop a)
  182.      0)
  183.     (t
  184.      (let ((cfrac (math-continued-fraction a tol))
  185.            (calc-prefer-frac t))
  186.        (math-eval-continued-fraction cfrac))))
  187. )
  188.  
  189. (defun math-continued-fraction (a tol)
  190.   (let ((calc-internal-prec (+ calc-internal-prec 2)))
  191.     (let ((cfrac nil)
  192.       (aa a)
  193.       (calc-prefer-frac nil)
  194.       int)
  195.       (while (or (null cfrac)
  196.          (and (not (Math-zerop aa))
  197.               (not (math-lessp-float
  198.                 (math-abs
  199.                  (math-sub a
  200.                        (let ((f (math-eval-continued-fraction
  201.                          cfrac)))
  202.                      (math-working "Fractionalize" f)
  203.                      f)))
  204.                 tol))))
  205.     (setq int (math-trunc aa)
  206.           aa (math-sub aa int)
  207.           cfrac (cons int cfrac))
  208.     (or (Math-zerop aa)
  209.         (setq aa (math-div 1 aa))))
  210.       cfrac))
  211. )
  212.  
  213. (defun math-eval-continued-fraction (cf)
  214.   (let ((n (car cf))
  215.     (d 1)
  216.     temp)
  217.     (while (setq cf (cdr cf))
  218.       (setq temp (math-add (math-mul (car cf) n) d)
  219.         d n
  220.         n temp))
  221.     (math-div n d))
  222. )
  223.  
  224.  
  225.  
  226. (defun calcFunc-fdiv (a b)   ; [R I I] [Public]
  227.   (if (Math-num-integerp a)
  228.       (if (Math-num-integerp b)
  229.       (if (Math-zerop b)
  230.           (math-reject-arg a "*Division by zero")
  231.         (math-make-frac (math-trunc a) (math-trunc b)))
  232.     (math-reject-arg b 'integerp))
  233.     (math-reject-arg a 'integerp))
  234. )
  235.  
  236.